perm filename NOTWRT.F4[MSS,LCS]1 blob
sn#086976 filedate 1974-03-19 generic text, type T, neo UTF8
00100 SUBROUTINE NOTWRT
00200 IMPLICIT INTEGER(A-Q,S-Z)
00300 COMMON/DL/IXRX,M,AA
00400 COMMON/SCM/V(78),ISCR,LCNT,RSTF,LIST(200),REND
00500 DIMENSION SU(250),RACNT(52),RDOT(7),XAC(6)
00600 REAL DIS,PWDS,CENTR,POS,STFF
00700 COMMON /STF/RSTFAC(8),RSTJC
00800 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
00900 COMMON/PLTR/PLT,RHT,DIS/XRN/RN(4000)/POSI/STFF(8),JJB,POS
01000 COMMON/NW/FILL(7),RNOTE(24)
01100 COMMON /NU/NUMQ(44),RNUMS(327),RACCI(32),NACCI(3)
01200 C FOR NOTE DRAWING
01300 EQUIVALENCE (JC,JQ(1)),(JD,JQ(2)),(JE,JQ(3)),(RJD,RJQ(2))
01400 1,(RJF,RJQ(4)),(JG,JQ(5)),(JH,JQ(6)),(JI,JQ(7)),(JJ,JQ(8))
01500 1,(JK,JQ(9)),(JF,JQ(4)),(RJE,RJQ(3)),(SU(1),RN(3001))
01600 1,(RJH,RJQ(6)),(RJG,RJQ(5)),(RX,JRX)
01700 DATA RACNT/4.0,1000.005,17.0,0.105, 8.0,1003.0, 7.014, 11.0
01800 1,13. ,1000. ,0.010,14.01,14. ,17. ,1001.018,7. ,13.018,27.,
01900 1 1004., 4.002, 6.004, 8.004,10.002,10., 8.102,6.102,4.
02000 1,32.0,1000.0,14.0,1007.007,7.107, 43.0,1012.01,11.006,9.003
02100 1, 7.001, 5.0, 9.002, 13.006, 15.01, 10.004, 13.009, 52.0,
02200 1 1002.008,3.003, 5.001, 8.0, 10.0, 13.001, 15.003, 16.008/
02300 DATA RDOT/1000.0, 0.103, 1.0, 1.103, 2.0, 2.103,0/
02400 1 , R5/5.0/, R66/66.0/, R72/72.0/,R18/18.0/,RSTM/14.54/
02500 1 ,XAC/9,14,18,28,33,44/
02600 C ALL DATA NUMS OVER 90 GIVE INVISIBLE VECTORS
02900 RST3=3.*RSTJC
03000 RST4=4.*RSTJC
03200 RST7=7.*RSTJC
03300 RSTX=RSTJC
03400 C FOR MINIS AT 245
03500
03600 1 CENTR=POS-R18*RSTJC+AMOD(RJD,100.0)*RST7
03700 C 'CENTR' IS VERTICAL PLACEMENT
03800 IF(JA.EQ.9)GO TO 90
03900 RMINI=RSTJC
04000 C OR SHOULD THIS ONLY BE IN NOTES, ETC? 15/9/72
04100
04200 IF(JA.EQ.101)GO TO 110
04300 RJB=JB
04400 RINV=1
04500 551 GO TO (11,20,30,241,50,242,70,80,90,11,30,80),JA
04700 IF(JA.EQ.30)GO TO 571
04800 C FOR BEAMS.
04900 90 CALL ITMSUB
05000 RETURN
05100
05200 20 IF(JE.GT.1)RJD=RJD-2
05300 RA=RJD
05400 RJG=RJF*10.
05500 C FOR DOTS
05600 202 CALL REST
05700 IF(JE.GT.1)GO TO 200
05800 IF(RJG.EQ.0)RETURN
05900 201 L=14
06000 IF(JE)L=19
06100 JB=JB+L*RSTJC
06200 RJD=8.+RA
06300 JA=6
06400 JE=7
06500 C IF P6=1 THE REST IS DOTTED
06600 GO TO 1
06700 200 JE=JE-1
06800 C FOR MULTIPLE TAILS ON 16TH REST, ETC.
06900 RJD=RJD+2.
07000 RJB=RJB+RST4
07100 GO TO 202
07200 80 CALL SLUR
07300 RETURN
07400
07500 C FOR TREMOLO SLASHES
07600 571 RJB=RJB+1
07700 RX=14.*RSTJC
07800 RJX=CENTR+RST7
07900 RJY=RJX-RX
08000 IF(JE.EQ.10)GO TO 42
08100 CALL EXCH(RJX,RJY)
08200 RJB=RJB-RX+1
08300 42 RX=RJB+26*RSTJC
08400 DO 40 K=1,JF
08500 DO 41 L=0,2
08600 RA=L*RSTJC
08900 41 CALL LINX(RJB,RJX+RA,RX,RJY+RA)
09000 RJX=RJX+RST7
09100 40 RJY=RJY+RST7
09200 RETURN
09300
09400 C FOR USER-DRAWN LIBRARY OF SYMBOLS
09500 30 CALL CLEFS
09600 RETURN
09700 291 RJB=RJB+8.*RSTJC
09800 IF(RINV)CENTR=CENTR-RST3
09900 C REMOVE '8' LATER
10000 CENTR=CENTR+2*RSTJC
10100
10200 29 RJX=RJB
10300 RJY=CENTR+RSTJC
10400 108 CALL RDRAW(1,7.0,RDOT,RSTJC,RJX,RJY,RSTJC)
10500 IF(JA.EQ.1.OR.RJG.GE.20.)GO TO 290
10600 RB=POS+52.*RSTJC
10700 IF(RJY.NE.RB)GO TO 6241
10800 C WHERE IS RB USED LATER?
10900 RJY=RJY-12*RSTJC
11000 GO TO 108
11100 C ABOVE FOR DOTS
11200 290 RJG=RJG-10.
11300 IF(RJG.LT.10.)GO TO 1342
11400 RJX=RJX+RSTJC*13.
11500 GO TO 108
11600
11700
11800 C FOR LEDGER LINES
11900 70 JK=JD
12000 C NOTE #
12100 170 RJW=RJB-9.*RMINI
12200 RJZ=RJB+22.*RMINI
12400 IF(JK)GO TO 71
12500 JX=JK
12600 JRX=13
12700 C********* 18/9/72
12800 GO TO 711
12900 71 JX=-JK
13000 JRX=JK*2+3
13100 711 RX=POS-18*RSTJC+RST7*JRX
13200 C********* 18/9/72
13300 IF(JF)RJZ=RJZ+2*RMINI
13400 C126 IF(PLT.EQ.-3)GO TO 1126
13500 C FOR 2-PASS PLOTTING
13600 C ******* ABOVE IS NOT USED, 15/9/72
14000 126 CALL LINX(RJW,RX,RJZ,RX)
14200 1126 IF(JX.EQ.1)GO TO 1122
14300 RX=RX+RSTJC*14.
14400 JX=JX-1
14500 GO TO 126
14600 1122 IF(JA.EQ.7)RETURN
14700 JI=-1
14800 GO TO 1121
14900
15000 11 STEM=JE/10
15100
15200 C NOTES****
15300 C RACTX=ABS(AMOD(RJF,1.0))*10.
15400 RJF=ABS(AMOD(RJF,1.0))*10.
15500 C RJF WILL HAVE ACCENT CODE # (.7=DOT, ETC.)
15600 1011 RG=19.0
15700 KL=1
15900 IF(PLT.NE.-1)RG=14.
16000 C FOR 2-PASS PLOTTING
16100 RJAC=RJB
16200 C TO SAVE POS. OF NOTE FOR ACCENT
16300 IF(IABS(JD).LT.100)GO TO 1221
16400 IF(IABS(JD).LT.200)GO TO 1012
16500 RG=24.0
16600 KL=20
16700 C FOR DIAMOND NOTES.
16800 GO TO 1013
16900 1012 RMINI=.6*RSTJC
17000 C FOR RMINI NOTES
17100 1013 JD=MOD(JD,100)
17200 RJD=RJD-100.
17300 IF(RJD.GT.160.)GO TO 1013
17400 C FOR MINI TAILS AND ACCIS. ETC.
17500 1221 JY=IABS(JF)
17600 IF(JY.LT.10.OR.JY.GE.30)GO TO 2221
17700 C P6 FOR HOMING TO RIGHT(10,30) OR LEFT(20) OF STEM(10,30=UP, 20=DOWN)
17800 C P6<0 = WHITE NOTE
17900 RQ=RSTM
18000 IF(JF)RQ=RQ+1.66
18100 C GETS WIDTH OF NOTE DISPLACEMENT
18200 IF(JY.EQ.20)RQ=-RQ
18300 RJB=RJB+RQ*RMINI
18400 2221 IF((JD.GT.1.AND.JD.LT.13).OR.JI.NE.0)GO TO 1121
18500 C ARE THERE LEDGER LINES?
18600 JK=(JD+1)/2-6
18700 IF(JK)JK=-((3-JD)/2)
18800 GO TO 170
18900 C IF JF≠0 NOTE IS FILLED IN
19000 1121 IF(JF.GE.0.AND.KL.EQ.1)GO TO 125
19100 CALL RDRAW(KL,RG,RNOTE,RMINI,RJB,CENTR,RMINI)
19200 GO TO 123
19300 125 IF(PLT)GO TO 1251
19400 CALL LINES(RJB,CENTR,3)
19600 RG=4.0
19700 GO TO 1253
19800 1251 CALL NOIR(RMINI)
19900 GO TO 123
20000
20100 1253 RG=RMINI*RG
20200 RA=RJB+RG
20400 DO 1252 K=1,7,3
20500 RB=FILL(K)*RMINI
20600 CALL LINES(RA,CENTR+RB,2)
20700 CALL LINES(RA,CENTR-RB,2)
20800 1252 RA=RA+RG
20900 C ABOVE IS NEW NOTES ROUTINE
21000
21100 123 RJE=RJE-JE
21200 C RJE=STEPS TO LEFT FOR ACCID. (.1=1 STEP)
21300 IF(STEM.EQ.0)GO TO 1242
21400 128 JG=MOD(JG,10)
21500 RG=(JG-1)*14
21600 IF(RG)RG=0
21700 IF(RJH.GE.999)RJH=0
21800 C NO EXTEN. OF STEM?
21900 RH=RJH*RST7
22000 C STEM EXTENSIONS ARE BY NOTE #S
22100 IF(STEM.NE.2)GO TO 1280
22200 RJX=RJB
22300 C FOR STEM DOWN (=2)
22400 RG=-RG-48.
22500 RH=-RH
22600 L=20
22700 RJY=3.
22800 RJD=RJD-3.7-RJH
22900 C RJD IS USED IN SUBR. TAIL - RJH IS STEM EXTENSION.
23000 RJW=-2
23100 RA=1.
23200 GO TO 129
23300 C NEXT IS FOR STEM UP.
23400 1280 RJX=RSTM
23500 RJW=2
23600 C FOR VERT. SPACING OF MULTIPLE TAILS
23700 RJD=RJD-2+RJH
23800 C 2 ABOVE AND 3.7 BEFORE ARE BECAUSE ORIG. POS. OF TAIL DRWING IS OFF.
23900 IF(JF.NE.0.AND.JF.NE.30)RJX=16.2
24000 C FOR HALF NOTES
24100 RJX=RJX*RMINI+RJB
24200 RG=RG+48.
24300 L=10
24400 RJY=-3.
24500 RA=-1.
24600 129 RJZ=CENTR+RH+RG*RMINI
24700 IF(RMINI.NE.RSTJC)RJW=RJW*.6
25200 CALL LINX(RJX,CENTR,RJX,RJZ)
25400 227 JE=JE-L
25500 C JE HAS ACCID. # NOW
25600 IF(JG.EQ.0)GO TO 1242
25700 C JUMP IF NO TAILS
25800 127 CALL TAIL(RJX,RA,RMINI)
25900 1028 JG=JG-1
26000 IF(JG.EQ.0)GO TO 327
26100 RJD=RJD+RJW
26200 C MOVES CENTR UP OR DOWN FOR NEXT TAIL
26300 GO TO 127
26400 327 IF(JJ.EQ.0)GO TO 1242
26500 RJY=RJZ-19*RSTJC
26600 RJZ=RJZ-RST4
26800 IF(RA.LT.0)GO TO 1327
26900 C NEXT IS FOR STEM DOWN SLASH
27000 RJY=RJZ+23*RSTJC
27100 RJZ=RJZ+RST7
27200 1327 RJX=RJX-RST7
27500 CALL LINX(RJX,RJY,RJX+17.*RSTJC,RJZ)
27600 C FOR SLASH ON GRACE NOTE TAIL
27700 1242 IF(RJG.LT.10.)GO TO 1342
27800 C FOR DOTTED NOTE-- P7>9
27900 RJX=RJAC+(24.+AMOD(RJG,1.0)*59.6)*RMINI
28000 RJY=CENTR+RSTJC
28300 IF(JY.EQ.10.OR.JY.EQ.30)RJX=RJX+RSTM
28350 C MOVES DOT TO LEFT
28400 IF(MOD(JD,2).EQ.0)GO TO 108
28500 RX=RST7
28600 IF(JY.GE.20)RX=-RX
28700 3342 RJY=RJY+RX
28800 GO TO 108
28900 C JY=30= STEM UP, INTERVAL OF SECOND.
29000 1342 RJB=RJB-RJE*59.6*RMINI
29100 C TO SPACE OUT ACCIDS.
29200 IF(RMINI.NE.RSTJC)RSTJC=.7*RSTJC
29300 C ↑↑↑↑ ↑↑↑↑↑ WAS RMINI
29400 C********* 18/9/72
29500 242 IF(JE.GE.0)GO TO 2421
29600 RINV=-RINV
29700 JE=-JE
29800 C NOW THAT 0 IS NOT USED FOR DOTS THE ABOVE 3 LINES COULD BE CHNGD
29900 C********** LAST # WAS 281?
30000 C b,#,NAT, ACC ∧, ACC >, FERMATA, DOT, REP MEAS., DASH
30100 2421 RH=14
30200 IF(JA.NE.6)GO TO 211
30300 STEM=0
30400 C FOR MISC. ITEMS
30500 210 IF(IABS(JD).LT.100)GO TO 3241
30600 JD=MOD(JD,100)
30700 RSTJC=.7*RSTJC
30800 3241 JEX=-1
30900 C FOR 2 MARKS AT ONCE.
31000 1241 IF(JE.GE.11)GO TO 28
31100 GO TO (211,211,211,28,28,222,249,60,27,27),JE
31200 RETURN
31300 C ERROR TRAP (I.E. JE=0)
31400
31500 241 CALL LINES(RJB,CENTR,3)
31600 GO TO 210
31700
31800 2422 IF(RJF.EQ.0)RETURN
32000 RJB=RJAC
32200 JE=(RJF+.001)*100.
32300 1249 IF(MOD(JE,10).GT.3)GO TO 249
32400 JE=JE/10
32500 IF(JE.GT.30)GO TO 1249
32600 C EXTRACTS ACCENT NUMBERS FROM DECIMALS IN P6.
33500 C ↑↑↑↑ ↑↑↑↑↑ WAS RMINI
33600 C WHAT ABOUT MINI ACCENTS?
33700 249 IF(JE.GT.30)GO TO 28
33800 IF(JE.GT.10)GO TO 246
33900 IF(JA.NE.1)GO TO 250
34000 RH=8
34100 RB=14.
34200 IF((JE.NE.7.AND.JE.NE.9).OR.MOD(JD,2).EQ.0)GO TO 244
34300 IF((STEM.LE.1.AND.JD.LT.5).OR.((STEM.EQ.2.OR.STEM.EQ.0)
34400 1 .AND.JD.GT.9))GO TO 244
34500 RB=21
34600 C PUTS ACCENT DOWN OR UP 1 SPACE. AVOIDS PUTTING DOT OR DASH ON LINE
34700 244 IF(STEM.EQ.1.OR.(STEM.EQ.0.AND.JD.LT.7))RB=-RB
34800 IF(JE.NE.6)GO TO 245
34900 IF(JD.LT.9.AND.STEM.EQ.2)GO TO 247
35000 IF(JD.GT.4.AND.STEM.EQ.1)GO TO 252
35100 245 CENTR=CENTR+RB*RSTX
35200 250 IF(JE.GT.10.OR.JE.LT.6)GO TO 247
35300 JA=6
35400 IF(JE.NE.7)GO TO 253
35500 C 7=DOT
35600 RXX=RJB
35700 RJB=RJB+6.7*RMINI
35800 C CENTERS THE DOT
35900 GO TO 29
36000 253 IF(JE.EQ.9)GO TO 271
36100 C 9=DASH
36200 251 IF(RB.LT.0)RINV=-RINV
36300 C FIX THIS!!!! FOR BOWINGS, ETC.
36400 222 CALL FERMTA(RINV)
36500 GO TO 5241
36600 252 RX=POS
36700 248 CENTR=RX
36800 GO TO 251
36900 246 IF(STEM.EQ.1)RB=70.
37000 IF(STEM.EQ.2)RB=21.
37100 C CHANGE R66 AND R72 TO NUMS WHEN RIGHT ONES ARE FOUND.
37200 GO TO 245
37300 247 RX=POS+R72*RSTJC
37400 IF(JE.EQ.6.OR.JE.EQ.26)GO TO 248
37500 C 26 IS NEW NUMB FOR FERMATA. TAKE OUT 6 EVENTUALLY.
37600 IF(JA.EQ.1.AND.JE.GT.10.AND.CENTR.LT.RX)CENTR=RX
37800 28 IF(JE.LT.30)GO TO 281
37900 JEX=MOD(JE,10)
38000 C JEX SAVES NEXT MARK.
38100 IF(JEX.LT.4)JEX=0
38200 JE=JE/10
38300 IF(JE.GT.30)RETURN
38400 C WON'T READ 415 ETC. (CORRECT=154)
38500 C DOES BOTTOM MARK FIRST, THEN TOP.
38600 CALL EXCH(JEX,JE)
38700 C PUTS UPBOW, DNBOW, ETC. ABOVE STACC., ETC.
38800 IF(JA.EQ.1)GO TO 249
38900 GO TO 1241
39000 281 X=1
39100 IF(JE.NE.4)GO TO 228
39200 X=5
39300 RJB=RJB+.5*RSTJC
39400 GO TO 328
40100 228 IF(JE.GT.10)X=XAC(JE-10)
40200 C X IS POINTER IN RACNT ARRAY
40300 328 RA=RMINI
40400 C OR RSTJC?
40500 IF(RINV.LT.0.OR.(STEM.EQ.1.AND.JE.EQ.4))RA=-RA
40600 CALL RDRAW(X+1,RACNT(X),RACNT,RA,RJB,CENTR,RMINI)
40700 C PTR, WDCNT, ARRAY,Y MULT,HOR ADD,VERT ADD, X,Y,MULT
40800 C IN ARRAY, 33.012 WOULD BE X=33, Y=12. 101.123 IS X=-1, Y=-23.
40900 GO TO 5241
41000 4241 JJJ=JE
41100 JE=JEX
41200 JEX=-1
41300 IF(JA.NE.1)GO TO 7241
41400 IF(JE.GT.10)GO TO 246
41500 IF(JE.EQ.7.AND.JJJ.NE.9)GO TO 249
41600 7241 RXX=RH*RMINI
41700 IF(STEM.EQ.1)RXX=-RXX
41800 CENTR=CENTR+RXX
41900 IF(JE.EQ.26)JE=6
42000 C TEMPORARY?? FIX
42100 GO TO 1241
42200 C >=5, ∧=4
42300 27 RJB=JB
42500 C DASHES
42700 271 CALL LINX(RJB,CENTR,RJB+RSTJC*14.,CENTR)
42800 5241 IF(JEX.GT.0)GO TO 4241
42900 C JEX IS FOR DOUBLE MARKS. (WHAT ABOUT DOT POSITION.)
43000 RETURN
43100 6241 RJB=RXX
43200 C RESET RJB AFTER A DOT.
43300 GO TO 5241
43400 211 IF(JE.EQ.0)GO TO 2422
43500 IF(JE.GT.3)GO TO 222
43700 C FOR 2-PASS PLOTTING (-2=THIN LINES, -3=HEAVY LINES)
43800 X=NACCI(JE)
44000 CALL RDRAW(X+1,RACCI(X),RACCI,RMINI,RJB,CENTR,RMINI)
44200 GO TO 2422
44300
44400 500 RJB=RJB-RST3
44500 JJB=JJB-RSTJC*13.
44600 C ADJUSTS POS. OF #S
44700 JE=JE-1
44800 GO TO 222
44900 C NUMBERS. 5, POS, STF, NOTE #, NUM, SIZE(DECI'S)
45000 50 RDIS=RJE
45100 JJJ=JF
45200 IF(RDIS.EQ.0)RDIS=1.
45300 PUNCT=0
45400 IF(JJJ.LT.44)GO TO 51
45500 PUNCT=JJJ
45600 IF(JJJ.EQ.44)JJJ=38
45700 IF(JJJ.GE.45)JJJ=36
45800 IF(JF.NE.46)GO TO 51
45900 RXX=4
46000 RJB=RJB-RXX*RSTJC
46100 RX=16
46200 CENTR=CENTR+RX*RSTJC
46300 51 RX=RDIS*RSTJC
46400 451 X=NUMQ(JJJ+1)
46500 C X=END # OF ITEM
46600 C X+1=1ST PART OF ITEM
46700 CALL RDRAW(X+1,RNUMS(X),RNUMS,RX,RJB,CENTR+RST3,RX)
46800 IF(PUNCT.EQ.0)GO TO 151
46900 IF(PUNCT.NE.46)GO TO 351
47000 RJB=RJB+2*RXX*RSTJC
47100 C FOR "
47200 651 PUNCT=0
47300 GO TO 451
47400 351 RXX=11
47500 C FOR : AND ;
47600 CENTR=CENTR+RXX*RSTJC
47700 JJJ=38
47800 GO TO 651
47900 151 IF(JA.EQ.101)GO TO 1005
48000 RETURN
48100
48200 110 JC=RJB
48300 IF(JC.NE.99)GO TO 1008
48400 CALL HYDPOG(2)
48500 RETURN
48600 1008 JF=0
48700 JE=0
48800 RSTJC=1.
48900 C SETS UP SCALE LINES.
49000 RJC=STFF(JC+4)+60
49100 RJ=RJC+60
49200 CENTR=RJC+74
49300 CALL DPYSET(2,SU,250)
49400 CALL DPYBRT(1)
49500 1001 POS=RJC+64
49600 DO 1002 MX=10,200,10
49700 RA=RHORZ(FLOAT(MX))
49800 RJB=RA-58
49900 IF(MX.GT.10)GO TO 50
50000 1005 IF(RJE.NE.0)GO TO 1007
50100 C JUMP FOR STAFF NUMBERS
50400 CALL LINX(RA,RJC,RA,RJ)
50500 JF=JF+1
50600 1002 IF(JF.EQ.10)JF=0
50700 CALL LINES(-596.0,RJ,2)
50800 CALL LINES(-596.0,RJC,2)
50900 RJE=1.5
51000 C NEXT SETS UP STAFF NUMBERS
51100 RJB=-620.
51200 DO 1007 K=-3,4
51300 CENTR=STFF(K+4)+21.
51400 JF=IABS(K)
51500 GO TO 50
51600 1007 CONTINUE
51700 CALL DPYOUT(2)
51800 CALL SETPOG(1)
51900 RETURN
52000
52100 C FOR 1 OR 2 BAR REP SIGNS.
52200 60 CALL BREP(RJB,RSTJC)
52300 END